home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / scm / Transcen < prev    next >
Text File  |  1993-01-21  |  3KB  |  93 lines
  1. ;;;; "Transcen.scm", Complex trancendental functions for SCM.
  2. ;;; Copyright (C) 1992, 1993 Jerry D. Hedden.
  3. ;;; See the file `COPYING' for terms applying to this program.
  4.  
  5. (define (exp z)
  6.   (if (real? z) ($exp z)
  7.       (make-polar ($exp (real-part z)) (imag-part z))))
  8.  
  9. (define (log z)
  10.   (if (and (real? z) (>= z 0))
  11.       ($log z)
  12.       (make-rectangular ($log (magnitude z)) (angle z))))
  13.  
  14. (define (sqrt z)
  15.   (if (real? z)
  16.       (if (negative? z) (make-rectangular 0 ($sqrt (- z)))
  17.       ($sqrt z))
  18.       (make-polar ($sqrt (magnitude z)) (/ (angle z) 2))))
  19.  
  20. (define expt
  21.   (let ((integer-expt integer-expt))
  22.     (lambda (z1 z2)
  23.       (cond ((exact? z2)
  24.          (integer-expt z1 z2))
  25.         ((and (real? z2) (real? z1) (>= z1 0))
  26.          ($expt z1 z2))
  27.         (else
  28.          (exp (* z2 (log z1))))))))
  29.  
  30. (define (sinh z)
  31.   (if (real? z) ($sinh z)
  32.       (let ((x (real-part z)) (y (imag-part z)))
  33.     (make-rectangular (* ($sinh x) ($cos y))
  34.               (* ($cosh x) ($sin y))))))
  35. (define (cosh z)
  36.   (if (real? z) ($cosh z)
  37.       (let ((x (real-part z)) (y (imag-part z)))
  38.     (make-rectangular (* ($cosh x) ($cos y))
  39.               (* ($sinh x) ($sin y))))))
  40. (define (tanh z)
  41.   (if (real? z) ($tanh z)
  42.       (let* ((x (* 2 (real-part z)))
  43.          (y (* 2 (imag-part z)))
  44.          (w (+ ($cosh x) ($cos y))))
  45.     (make-rectangular (/ ($sinh x) w) (/ ($sin y) w)))))
  46.  
  47. (define (asinh z)
  48.   (if (real? z) ($asinh z)
  49.       (log (+ z (sqrt (+ (* z z) 1))))))
  50.  
  51. (define (acosh z)
  52.   (if (and (real? z) (>= z 1))
  53.       ($acosh z)
  54.       (log (+ z (sqrt (- (* z z) 1))))))
  55.  
  56. (define (atanh z)
  57.   (if (and (real? z) (> z -1) (< z 1))
  58.       ($atanh z)
  59.       (/ (log (/ (+ 1 z) (- 1 z))) 2)))
  60.  
  61. (define (sin z)
  62.   (if (real? z) ($sin z)
  63.       (let ((x (real-part z)) (y (imag-part z)))
  64.     (make-rectangular (* ($sin x) ($cosh y))
  65.               (* ($cos x) ($sinh y))))))
  66. (define (cos z)
  67.   (if (real? z) ($cos z)
  68.       (let ((x (real-part z)) (y (imag-part z)))
  69.     (make-rectangular (* ($cos x) ($cosh y))
  70.               (- (* ($sin x) ($sinh y)))))))
  71. (define (tan z)
  72.   (if (real? z) ($tan z)
  73.       (let* ((x (* 2 (real-part z)))
  74.          (y (* 2 (imag-part z)))
  75.          (w (+ ($cos x) ($cosh y))))
  76.     (make-rectangular (/ ($sin x) w) (/ ($sinh y) w)))))
  77.  
  78. (define (asin z)
  79.   (if (and (real? z) (>= z -1) (<= z 1))
  80.       ($asin z)
  81.       (* -i (asinh (* +i z)))))
  82.  
  83. (define (acos z)
  84.   (if (and (real? z) (>= z -1) (<= z 1))
  85.       ($acos z)
  86.       (+ (/ (angle -1) 2) (* +i (asinh (* +i z))))))
  87.  
  88. (define (atan z . y)
  89.   (if (null? y)
  90.       (if (real? z) ($atan z)
  91.       (/ (log (/ (- +i z) (+ +i z))) +2i))
  92.       ($atan2 z (car y))))
  93.